home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / C and C++ / Compilers⁄Interps / kevoSource / context.c < prev    next >
Text File  |  1993-05-14  |  26KB  |  1,052 lines
  1. /* Kevo -- a prototype-based object-oriented language */
  2. /* (c) Antero Taivalsaari 1991-1993                   */
  3. /* Some parts (c) Antero Taivalsaari 1986-1988           */
  4. /* context.c: Name space (context) management internals */
  5.  
  6. #include "global.h"
  7. #include "portGlobal.h"
  8.  
  9. /*--------------------------------------------------------------------------*/
  10. /* Context management operations */
  11.  
  12. PAIR*     LatestPair;    /* Pointer to the latest name in the dictionary  */
  13.                     /* Needed only for setting flags after 'addPair' */
  14.  
  15. /* hash(): hash function */
  16.  
  17. /* inlined for speed (see the header file 'context.h')
  18. int hash(identifier)
  19. char* identifier;
  20. {
  21.     return((int)*identifier % CONTEXTSIZE);
  22. }
  23. */
  24.  
  25.  
  26. /* lowCreateContext(): low-level context creation */
  27.  
  28. CONTEXT* lowCreateContext()
  29. {
  30.   return((CONTEXT*)mycalloc(1, sizeof(CONTEXT)));
  31. }
  32.  
  33.  
  34. /* xCreateContext(): another low-level context creation */
  35. /* which is needed only in root context initialization */
  36. /* Since 'dummyContext' and (=context) have not been defined */
  37. /* when initializing root contexts, we cannot initialize */
  38. /* the clone families of these contexts (using createList) */
  39.  
  40. CONTEXT* xCreateContext()
  41. {
  42.   CONTEXT* newContext = lowCreateContext();
  43.  
  44.     /* Attach the context to the end of the global context list */
  45.     if (lastContext) {
  46.         lastContext->nextContext = newContext;
  47.         lastContext = newContext;
  48.     }
  49.  
  50.     return(newContext);
  51. }
  52.  
  53.  
  54. /* createContext(): create and initialize a new context (high-level) */
  55.  
  56. CONTEXT* createContext()
  57. {
  58.   CONTEXT* newContext = xCreateContext();
  59.  
  60.     /* Initialize the family lists */
  61.     newContext->cloneFamily     = createList();
  62.     newContext->parentFamilies     = createList();
  63.     newContext->childFamilies     = createList();
  64.  
  65.     return(newContext);
  66. }
  67.  
  68.  
  69. /* copyContext(): duplicate an existing context with all its names */
  70. /* this operation is needed internally when new clone families are */
  71. /* being derived. Note that family lists are not copied (shallow copy) */
  72.  
  73. CONTEXT* copyContext(oldC)
  74. CONTEXT* oldC;
  75. {
  76.   CONTEXT* newC;
  77.   PAIR* oldPair = oldC->firstPair;
  78.   PAIR* newPair;
  79.  
  80.   newC = createContext(); 
  81.   while (oldPair) {
  82.         newPair = addPair(newC, oldPair->nfa, oldPair->ofa);
  83.         newPair->ffa = oldPair->ffa;    /* Duplicate flag field too */
  84.         oldPair = oldPair->sfa;
  85.   }
  86.  
  87.   return(newC);
  88. }
  89.  
  90.  
  91. /* This operation is needed only internally in the next operation */
  92. /* to find the previous context in the context list */
  93.  
  94. CONTEXT* findPrevContext(context)
  95. CONTEXT* context;
  96. {
  97.   /* The first context in the context list is always 'rootContext' */
  98.   CONTEXT* thisContext = rootContext; 
  99.  
  100.     while (thisContext) {
  101.         if (thisContext->nextContext == context) return(thisContext);
  102.         thisContext = thisContext->nextContext;
  103.     }
  104.  
  105.     fprintf(confile, "== Integrity error detected: context link damaged (no prev ctxt found) ==\n");
  106.     reportIntegrityError();
  107.     ownLongJmp();
  108. }
  109.  
  110.  
  111. /* deleteContext(): delete an existing context with all its names. */
  112. /* Note that family lists are not deleted (must be done separately) */
  113. /* Remember that contexts are linked in a singly-linked list so as */
  114. /* to allow type name lookup, so we must remove the context from */
  115. /* that list too */
  116.  
  117. void deleteContext(context)
  118. CONTEXT* context;
  119. {
  120.   CONTEXT* prevCtxt = findPrevContext(context);
  121.   CONTEXT* nextCtxt = context->nextContext;
  122.   PAIR*    thisPair = context->firstPair;
  123.  
  124.     /* Remove the context from the context list */
  125.     if (prevCtxt) {
  126.         prevCtxt->nextContext = nextCtxt;
  127.         if (lastContext == context) lastContext = prevCtxt; 
  128.     }
  129.     else {
  130.         fprintf(confile, "== Integrity error detected: attempt to remove 'rootContext' ==\n");
  131.         reportIntegrityError();
  132.         ownLongJmp();
  133.     }
  134.     
  135.     /* Deallocate the pairs */
  136.     while (thisPair) {
  137.         PAIR* tempPair = thisPair->sfa;
  138.         free(thisPair);
  139.         thisPair = tempPair;
  140.     }
  141.     
  142.     /* Deallocate the context itself */
  143.     free(context);
  144. }
  145.  
  146.  
  147. /* comparePairs(): compare if two pairs are equivalent.
  148.     The comparison is based on the equivalence of names,
  149.     encapsulation flags, and operations. 
  150.     
  151.     The equality of operations is based simply on the identity
  152.     of the operations (physically same code) rather than behavioral
  153.     comparison. More clever schemes should be examined later.
  154.     
  155.     The operation returns TRUE if the pairs are equal.
  156. */
  157. int comparePairs(pair1, pair2)
  158. PAIR* pair1;
  159. PAIR* pair2;
  160. {
  161.     if (!pair1) return(FALSE);
  162.     if (!pair2) return(FALSE);
  163.     if (pair1->ofa != pair2->ofa) return(FALSE);
  164.     if (strcmp(pair1->nfa, pair2->nfa) != 0) return(FALSE);
  165.     if (pair1->ffa != pair2->ffa) return(FALSE);
  166.     return(TRUE);
  167. }
  168.  
  169.  
  170. /* compareContexts(): compare if two contexts are equivalent.
  171.     The operation returns TRUE if the contexts are equal.
  172. */
  173. int compareContexts(context1, context2)
  174. CONTEXT* context1;
  175. CONTEXT* context2;
  176. {
  177.   PAIR* thisPair1 = context1->firstPair;
  178.   PAIR* thisPair2 = context2->firstPair;
  179.   
  180.     while (thisPair1) {
  181.         /* Any incompatible pair will cause the comparison to fail */
  182.         if (!comparePairs(thisPair1, thisPair2)) return(FALSE);
  183.         
  184.         thisPair1 = thisPair1->sfa;
  185.         thisPair2 = thisPair2->sfa;
  186.     }
  187.  
  188.     if (thisPair2) return(FALSE);
  189.     else return(TRUE);
  190. }
  191.  
  192.  
  193. /* compareContextResemblance(): compare if two context
  194.     have at least something in common (at least one of
  195.     the properties in them is exactly the same)
  196. */
  197. int compareContextResemblance(context1, context2)
  198. CONTEXT* context1;
  199. CONTEXT* context2;
  200. {
  201.   PAIR* thisPair1 = context1->firstPair;
  202.   PAIR* thisPair2;
  203.  
  204.     while (thisPair1) {
  205.         thisPair2 = context2->firstPair;
  206.         while (thisPair2) {
  207.             /* Any compatible pair will cause the comparison to succeed */
  208.             if (comparePairs(thisPair1, thisPair2)) return(TRUE);
  209.             thisPair2 = thisPair2->sfa;
  210.         }
  211.         thisPair1 = thisPair1->sfa;
  212.     }
  213.     return(FALSE);
  214. }
  215.  
  216.  
  217. /* isContextObject(): check if a given object is */
  218. /* a proper OOP object with its own context */
  219. /* This operation is fairly slow, and is used mainly in the browser */
  220.  
  221. int isContextObject(object)
  222. OBJECT* object;
  223. {
  224.       if (maskedFetch((int*)object) && maskedFetch((int*)object->mfa))
  225.           return(object->mfa->efa == (int*)oContext ? TRUE : FALSE);
  226.     else return(FALSE);
  227. }
  228.  
  229.  
  230. /* getContext(): given an OOP object, return the corresponding context */
  231. /* Inlined for speed (see the header file 'global.h'
  232. CONTEXT* getContext(object)
  233. OBJECT* object;
  234. {
  235.     return((CONTEXT*)object->mfa->pfa);
  236. }
  237. */
  238.  
  239.  
  240. /* initRootContexts(): initialize the root context. */
  241. /* This operation is needed in 'main.c' */
  242.  
  243. void initRootContexts()
  244. {
  245.     /* Create an "empty" dummy context. This is useful for some objects */
  246.     /* so that we can view them as objects from the browser */
  247.     dummyContext = lowCreateContext();
  248.  
  249.     /* Create a root context for system primitives */
  250.     /* This is known as 'SystemRoot' in the high-level Kevo */
  251.     rootContext = lastContext = xCreateContext();
  252.  
  253.     /* Create a root context for user-given definitions */
  254.     /* This is known as 'Root' in the high-level Kevo */
  255.     userContext = xCreateContext();
  256. }
  257.  
  258.  
  259. /* initRootFamilies(): initialize the clone family lists */
  260. /* of basic contexts. These could not be initialized property */
  261. /* earlier, because '(=context)' and dummyContext were not */
  262. /* declared when calling 'createList()' */
  263. void initRootFamilies()
  264. {
  265.     dummyContext->cloneFamily    = createList();
  266.     dummyContext->parentFamilies = createList();
  267.     dummyContext->childFamilies  = createList();
  268.  
  269.     rootContext->cloneFamily     = createList();
  270.     rootContext->parentFamilies = createList();
  271.     rootContext->childFamilies     = createList();
  272.  
  273.     userContext->cloneFamily     = createList();
  274.     userContext->parentFamilies = createList();
  275.     userContext->childFamilies     = createList();
  276. }
  277.  
  278.  
  279. /*--------------------------------------------------------------------------*/
  280. /* Pair (name) specific context operations */
  281.  
  282. /* addPair(): add a new pair to an existing context */
  283.  
  284. PAIR* addPair(context, identifier, referent)
  285. CONTEXT* context;
  286. char*     identifier;
  287. OBJECT*     referent;
  288. {
  289.   int thread = hash(identifier);
  290.  
  291.   /* Allocate a new pair */
  292.   PAIR* newPair = (PAIR*)mymalloc(sizeof(PAIR));
  293.    
  294.   /* Initialize fields */
  295.   newPair->nfa = identifier;     /* Note that the string is not copied */
  296.   newPair->ofa = referent;        /* The object */
  297.   newPair->cfa = context;        /* Pair contains a backpointer to the context */
  298.   newPair->ffa = 0;                /* Flags are all down at first */
  299.  
  300.   /* Add the new pair to the end of the correct thread in context */
  301.   newPair->lfa = context->lastPair[thread];
  302.   context->lastPair[thread] = newPair;
  303.  
  304.   /* Set also the reverse link */
  305.   if (context->latestPair) context->latestPair->sfa = newPair;
  306.   else context->firstPair = newPair;
  307.  
  308.   context->latestPair = newPair;
  309.   newPair->sfa = NIL;
  310.  
  311.   /* Set the global variable to point to the latest pair */
  312.   LatestPair = newPair;
  313.  
  314.   return(newPair);
  315. }
  316.  
  317.  
  318. /* findSurroundings: find the surrounding four pairs for the given pair.
  319.    This operation is used only internally in some dictionary manipulation
  320.    operations to allow easy link manipulation.
  321. */
  322. void findSurroundings(thePair, theThread, prevPair, succPair, prevInThread, succInThread)
  323. PAIR* thePair;
  324. int theThread;
  325. PAIR** prevPair;        /* Previous pair in the context before 'thePair' */
  326. PAIR** succPair;        /* Next pair in the context after 'thePair' */
  327. PAIR** prevInThread;    /* Previous pair in 'theThread' before 'thePair' */
  328. PAIR** succInThread;    /* Next pair in 'theThread' after 'thePair' */
  329. {
  330.   CONTEXT* context = thePair->cfa;
  331.   PAIR* thisPair = context->firstPair;
  332.   
  333.     /* Initialize the return values */
  334.     *prevPair = NIL;
  335.     *succPair = thePair->sfa;
  336.     *prevInThread = NIL;
  337.     *succInThread = NIL;
  338.     
  339.     while (thisPair) {
  340.         if (thisPair == thePair) goto forward;
  341.         if (hash(thisPair->nfa) == theThread) *prevInThread = thisPair;
  342.         *prevPair = thisPair;
  343.         thisPair = thisPair->sfa;
  344.     }
  345.     
  346.     /* 'thePair' was not found in the context -> serious error */
  347.     fprintf(confile, "== Integrity error detected: pair not found in 'findSurroundings' ==\n");
  348.     reportIntegrityError();
  349.     ownLongJmp();
  350.     
  351. forward:
  352.     /* Find the next pair in the requested thread */
  353.     while ((thisPair = thisPair->sfa) != NIL) {
  354.         if (hash(thisPair->nfa) == theThread) {
  355.             *succInThread = thisPair;
  356.             break;
  357.         }
  358.     }
  359. }
  360.  
  361.  
  362. /* unlinkPair(): remove a pair from a context */
  363. /* 
  364.     Remember that we must unlink the pair from both directions. 
  365.     This is a bit problematic, since to the other direction 
  366.     dictionary is hashed (multi-linked), and to the other there is
  367.     only a singly linked list.
  368. */
  369.  
  370. void unlinkPair(pair)
  371. PAIR* pair;    
  372. {
  373.   CONTEXT* context  = pair->cfa;
  374.   int      thread   = hash(pair->nfa);
  375.   PAIR*       prevPair;
  376.   PAIR*       succPair;
  377.   PAIR*    prevInThread;
  378.   PAIR*       succInThread;
  379.  
  380.     findSurroundings(pair, thread, &prevPair, &succPair, &prevInThread, &succInThread);
  381.     
  382.     /* Remove the pair from the successor link */
  383.     if (prevPair)
  384.          prevPair->sfa = pair->sfa;
  385.     else context->firstPair = pair->sfa;
  386.     
  387.     if (succPair == NIL) context->latestPair = prevPair;
  388.     
  389.     /* Remove the pair from the predecessor link */
  390.     if (succInThread)
  391.          succInThread->lfa = pair->lfa;
  392.     else context->lastPair[thread] = pair->lfa;
  393. }
  394.  
  395.  
  396. /* renamePair(): rename a pair in a context */
  397. /* 
  398.     This operation is also a bit problematic to implement owing
  399.     to the hashed (multi-linked) structure of the dictionary.
  400. */
  401.  
  402. void renamePair(oldPair, newName)
  403. PAIR* oldPair;
  404. char* newName;
  405. {
  406.   CONTEXT*     context   = oldPair->cfa;
  407.   int          oldThread = hash(oldPair->nfa);
  408.   int        newThread = hash(newName);
  409.   PAIR*        newPair;
  410.   PAIR*        thisPair;
  411.   PAIR*        succInThread;
  412.  
  413.     /* 
  414.         If the new name hashes to the same link than the previous one,
  415.         things are simple, and we can directly change the name field.
  416.     */
  417.     if (oldThread == newThread) {
  418.         oldPair->nfa = newName;
  419.         return;
  420.     }
  421.     
  422.     /* 
  423.         Otherwise, things get a bit more complicated. 
  424.         Fortunately, the pairs are linked together also to the other 
  425.         direction. The successor link is only singly linked (unhashed),
  426.         so we know the exact definition order of pairs.
  427.     */
  428.  
  429.     /* Allocate a new pair */
  430.     newPair = (PAIR*)mymalloc(sizeof(PAIR));
  431.    
  432.     /* Initialize/copy the fields */
  433.     newPair->nfa = newName;
  434.     newPair->ofa = oldPair->ofa;
  435.     newPair->cfa = oldPair->cfa;
  436.     newPair->ffa = oldPair->ffa;
  437.  
  438.     /* New pair will be added right after the old one in the successor link */
  439.     /* Locate the next pair in the new thread after 'oldPair' */
  440.  
  441.     thisPair = oldPair;
  442.     succInThread = NIL;
  443.     
  444.     while (thisPair) {
  445.         if (hash(thisPair->nfa) == newThread) {
  446.             succInThread = thisPair;
  447.              break;
  448.         }
  449.         thisPair = thisPair->sfa;
  450.     }
  451.  
  452.     /* Insert the new pair to the insertion point */
  453.     newPair->sfa = oldPair->sfa;
  454.     oldPair->sfa = newPair;
  455.  
  456.     if (succInThread) {
  457.         newPair->lfa = succInThread->lfa;
  458.         succInThread->lfa = newPair;
  459.     }
  460.     else {
  461.         newPair->lfa = context->lastPair[newThread];
  462.         context->lastPair[newThread] = newPair;
  463.     }
  464.     
  465.     if (context->latestPair == oldPair) 
  466.         context->latestPair = newPair;
  467.     
  468.     /* Finally, remove the old pair from the context */
  469.     unlinkPair(oldPair);
  470.     free(oldPair);
  471. }
  472.  
  473.  
  474. /* hide(): make the latest pair "hidden" */
  475.  
  476. void hide()
  477. {
  478.   LatestPair->ffa |= HiddenFlag;
  479. }
  480.  
  481.  
  482. /* copyPair(): make a copy of a pair */
  483. /* This operation is needed for the user interface (CUT, COPY, PASTE) */
  484.  
  485. PAIR* copyPair(oldPair)
  486. PAIR* oldPair;
  487. {
  488.   PAIR* newPair = (PAIR*)mymalloc(sizeof(PAIR));
  489.  
  490.     /* Copy fields */
  491.     *newPair = *oldPair;
  492.     return(newPair);
  493. }
  494.     
  495.  
  496. /* addBeforePair(): link the given pair in front of the requested pair */
  497. /* 
  498.     This operation allows new properties to be added to arbitrary
  499.     points within objects, and it is needed for the user interface
  500.     (CUT, COPY, PASTE).
  501.  
  502.     Different cases:
  503.     1) if the context is empty before addition (should not happen)
  504.     2) if added before the first pair in the context
  505.     3) if added before the first pair in a thread
  506.     4) other
  507. */
  508. PAIR* addBeforePair(beforePair, newPair)
  509. PAIR* beforePair;    /* The pair before which the new pair is added */
  510. PAIR* newPair;        /* The pair to be added */
  511. {
  512.   CONTEXT* context = beforePair->cfa;
  513.   int beforeThread = hash(beforePair->nfa);
  514.   int newThread     = hash(newPair->nfa);
  515.   PAIR* prevPair;
  516.   PAIR* succPair;
  517.   PAIR* prevInThread;
  518.   PAIR* succInThread;
  519.     
  520.     findSurroundings(beforePair, newThread, &prevPair, &succPair, &prevInThread, &succInThread);
  521.     
  522.     /* Add the pair to the successor link */
  523.     newPair->sfa = beforePair;
  524.     
  525.     if (prevPair)
  526.          prevPair->sfa = newPair;
  527.     else context->firstPair = newPair;
  528.     
  529.     /* Add the pair to the predecessor link */
  530.     newPair->lfa = prevInThread;
  531.  
  532.     /* 
  533.         If we are adding to the same thread, then the successor 
  534.         is the 'beforePair' rather than its successor. 
  535.     */
  536.     if (beforeThread == newThread) succInThread = beforePair;
  537.     
  538.     if (succInThread)
  539.          succInThread->lfa = newPair;
  540.     else context->lastPair[newThread] = newPair;
  541.  
  542.     /* Finally, change the new pair's context field to 'context' */
  543.     newPair->cfa = context;
  544.  
  545.     return(newPair);
  546. } 
  547.  
  548.  
  549. /*--------------------------------------------------------------------------*/
  550. /* Finding operations (used in searching names and objects from contexts) */
  551.  
  552. /* findPairInThis(): find a pair from a specific context given a string */
  553.  
  554. PAIR* findPairInThis(context, identifier)
  555. CONTEXT* context;
  556. char*     identifier;    
  557. {
  558.            int   thread   = hash(identifier);
  559.   register PAIR* tempPair = context->lastPair[thread];
  560.  
  561.   while (tempPair) {
  562.     if (!(tempPair->ffa & SmudgeFlag) && 
  563.        strcmp(tempPair->nfa, identifier) == 0) 
  564.        return(tempPair); 
  565.     tempPair = tempPair->lfa;
  566.   }
  567.   return(NIL);
  568. }
  569.  
  570.  
  571. /* findPairBackward(): find a pair using a certain search order. */
  572. /* First the current context (self) will be searched, then 'Root' */
  573. /* (user-level root) and finally 'SystemRoot' (system primitives). */
  574.  
  575. PAIR* findPairBackward(identifier)
  576. char* identifier;
  577. {
  578.   register PAIR* thisPair;
  579.   
  580.     if (thisPair = findPairInThis(getContext((OBJECT*)topContext), identifier))
  581.           return(thisPair);
  582.       
  583.     if (thisPair = findPairInThis(userContext, identifier))
  584.         return(thisPair);
  585.       
  586.     if (thisPair = findPairInThis(rootContext, identifier))
  587.         return(thisPair);
  588.       
  589.     return(NIL);
  590. }
  591.  
  592.  
  593. /* findNameInThis(): find a matching pair for a given object in a specific context */
  594.  
  595. PAIR* findNameInThis(context, object)
  596. CONTEXT* context;
  597. OBJECT*     object;    
  598. {
  599.   int thread;
  600.  
  601.   for (thread = 0; thread < CONTEXTSIZE; thread++) {
  602.     PAIR* tempPair = context->lastPair[thread];
  603.  
  604.     while (tempPair) {
  605.         if (!(tempPair->ffa & SmudgeFlag) && tempPair->ofa == object) 
  606.             return(tempPair); 
  607.         tempPair = tempPair->lfa;
  608.     }
  609.   }
  610.   return(NIL);
  611. }
  612.  
  613.  
  614. /* findNameBackward(): find a matching pair using a backward search order */
  615. /* see 'findPairBackward' above */
  616.  
  617. PAIR* findNameBackward(object)
  618. OBJECT* object;
  619. {
  620.   PAIR* thisPair;
  621.  
  622.     if (!maskedFetch((int*)object)) return(NIL);
  623.   
  624.     if (thisPair = findNameInThis(getContext((OBJECT*)topContext), object))
  625.           return(thisPair);
  626.       
  627.     if (thisPair = findNameInThis(userContext, object))
  628.         return(thisPair);
  629.       
  630.     if (thisPair = findNameInThis(rootContext, object))
  631.         return(thisPair);
  632.       
  633.     return(NIL);
  634. }
  635.  
  636.  
  637. /* findNameForward(): find a matching pair by searching all the contexts */
  638. /* in the first-defined-first order */
  639.  
  640. PAIR* findNameForward(object)
  641. OBJECT* object;
  642. {
  643.   CONTEXT*  thisContext = rootContext;
  644.   PAIR*     thisPair;
  645.   
  646.     if (!maskedFetch((int*)object)) return(NIL); 
  647.   
  648.     while (thisContext) {
  649.         if (thisPair = findNameInThis(thisContext, object)) return(thisPair);
  650.         thisContext = thisContext->nextContext;
  651.     }
  652.     
  653.     return(NIL);
  654. }
  655.  
  656.  
  657. /* findTypeInThis(): find a matching object for a given context object */
  658. /* This object is the "type" of that context */
  659. /* 
  660.     This operation is needed for object-oriented programming to print the 
  661.     types of objects automatically. Compared to other finding operations, 
  662.     the search order in this operation is backwards (from the earlier defined
  663.     things towards later defined ones).
  664.  
  665.     Due to the very indirect nature of objects in our system, this operation
  666.     is admittedly rather complicated. Furthermore, possible bus errors caused
  667.     by high memory references must be avoided, causing extra complexity. 
  668. */
  669.  
  670. PAIR* findTypeInThis(context, ctxtObject)
  671. CONTEXT* context;
  672. OBJECT*  ctxtObject;
  673. {
  674.   CONTEXT* desiredCtxt;
  675.   PAIR*       tempPair;
  676.     
  677.   desiredCtxt = getContext(ctxtObject);
  678.   tempPair    = context->firstPair;
  679.   
  680.     while (tempPair) {
  681.         if (!(tempPair->ffa & SmudgeFlag)) {
  682.             OBJECT* object = tempPair->ofa;
  683.  
  684.             /* We search mainly for REF objects */
  685.               if (object && object->sfa == DATAOFFSET && 
  686.                  (object = (OBJECT*)object->mfa->pfa)) {
  687.                   if (maskedFetch((int*)object) &&
  688.                       object->sfa > 0 &&
  689.                       object->mfa->efa == (int*)oContext && 
  690.                       object->mfa->pfa == (int*)desiredCtxt) return(tempPair);
  691.               }
  692.           }
  693.         tempPair = tempPair->sfa;    /* get next pair */
  694.     }
  695.     return(NIL);
  696. }
  697.  
  698.  
  699. /* findTypeForward(): this is the generalization of 'findTypeInThis()' */
  700. /* Search through all the contexts using their definition order list */
  701.  
  702. PAIR* findTypeForward(ctxtObject)
  703. OBJECT* ctxtObject;
  704. {
  705.   CONTEXT*  thisContext = userContext;
  706.   PAIR*     thisPair;
  707.  
  708.     if (!isContextObject(ctxtObject)) return(NIL);
  709.  
  710.     while(thisContext) {
  711.         if (thisPair = findTypeInThis(thisContext, ctxtObject)) return(thisPair);
  712.         thisContext = thisContext->nextContext;
  713.     }
  714.     
  715.     return(NIL);
  716. }
  717.  
  718.     
  719.  
  720. /* findPrimName(): find the name part of a primitive function. */
  721. /* It is assumed that C primitives reside only in the system root context, */
  722. /* so we search only that context. */
  723.  
  724. PAIR* findPrimName(prim)
  725. int*     prim;    
  726. {
  727.   int thread;
  728.  
  729.   for (thread = 0; thread < CONTEXTSIZE; thread++) {
  730.     PAIR* tempPair = rootContext->lastPair[thread];
  731.  
  732.     while (tempPair) {
  733.         if (tempPair->ofa && tempPair->ofa->mfa == (STORE*)prim) return(tempPair); 
  734.         tempPair = tempPair->lfa;
  735.     }
  736.   }
  737.   return(NIL);
  738. }
  739.  
  740.  
  741. /* ------------------------------------------------------------------------ */
  742. /* Context operations for object-oriented programming */
  743.  
  744. /* nonSelfLookUp(): find a matching pair in the context starting */
  745. /* from a given pair, but accept only the non-hidden properties. */
  746.  
  747. PAIR* nonSelfLookUp(thisPair, identifier)
  748. PAIR* thisPair;
  749. char* identifier;    
  750. {
  751.     while (thisPair) {
  752.         if (strcmp(thisPair->nfa, identifier) == 0 && !(thisPair->ffa & HiddenFlag)) 
  753.             return(thisPair); 
  754.         thisPair = thisPair->lfa;
  755.     }
  756.     return(NIL);
  757. }
  758.  
  759.  
  760. /* selfLookUp(): find a matching pair in the context starting */
  761. /* from a given pair, accepting also the hidden properties. */
  762.  
  763. PAIR* selfLookUp(thisPair, identifier)
  764. PAIR* thisPair;
  765. char* identifier;    
  766. {
  767.     while (thisPair) {
  768.         if (strcmp(thisPair->nfa, identifier) == 0) return(thisPair); 
  769.         thisPair = thisPair->lfa;
  770.     }
  771.     return(NIL);
  772. }
  773.  
  774.  
  775. /* messageLookUp(): basic lookup routine for object-oriented programming. */
  776. /* find a matching pair in the given context object, but search the non-hidden */
  777. /* (not encapsulated) properties only if the message comes from outside 'self' */
  778.  
  779. PAIR* messageLookUp(object, identifier)
  780. OBJECT* object;
  781. char*    identifier;
  782. {
  783.   CONTEXT*     context = getContext(object);
  784.   int         thread = hash(identifier);
  785.   PAIR*     thisPair = context->lastPair[thread];
  786.  
  787.     if (object == (OBJECT*)topContext) {
  788.         /* 'selfLookUp() "inlined" for speed */
  789.         while (thisPair) {
  790.             if (strcmp(thisPair->nfa, identifier) == 0) return(thisPair); 
  791.             thisPair = thisPair->lfa;
  792.         }
  793.     }
  794.     else {
  795.         /* nonSelfLookUp() "inlined" for speed */
  796.         while (thisPair) {
  797.             if (strcmp(thisPair->nfa, identifier) == 0 && !(thisPair->ffa & HiddenFlag)) 
  798.                 return(thisPair); 
  799.             thisPair = thisPair->lfa;
  800.         }
  801.         return(NIL);
  802.     }
  803. }
  804.  
  805.  
  806. /* respondsTo(): test if a certain object responds to a certain message */
  807. /* This operation does not refer to context stack, so it can invoked also */
  808. /* by the user interface */
  809.  
  810. PAIR* respondsTo(object, identifier)
  811. OBJECT* object;
  812. char*     identifier;
  813. {
  814.   CONTEXT* context = getContext(object);
  815.   int thread = hash(identifier);
  816.   PAIR* startPair = context->lastPair[thread];
  817.     
  818.     return nonSelfLookUp(startPair, identifier);
  819. }
  820.     
  821.  
  822. /* getREFslot(): gets the storage address of a REF (SHAREDVAR) or CONST slot */
  823.  
  824. OBJECT** getREFslot(thisPair)
  825. PAIR*     thisPair;
  826. {
  827.   STORE* store;
  828.   
  829.     if (thisPair->ofa && (store = thisPair->ofa->mfa)) 
  830.          return((OBJECT**)&store->pfa);
  831.     else return(NIL);
  832. }
  833.  
  834.         
  835. /* getVARoffset(): gets the offset of a VAR slot */
  836. /* Remember: data slots are offseted with DATAOFFSET */
  837. /* (i.e., the offset to the first data slot is 2, second = 3, ...) */
  838.  
  839. int getVARoffset(thisPair)
  840. PAIR* thisPair;
  841. {
  842.   OBJECT** offsetAddr = getREFslot(thisPair);
  843.  
  844.     if (offsetAddr)
  845.          return((int)*offsetAddr);
  846.     else return(0);
  847. }
  848.  
  849.  
  850. /* getVARslot(): gets the storage address of a VAR slot */
  851.  
  852. OBJECT** getVARslot(ctxtObject, thisPair)
  853. OBJECT* ctxtObject;
  854. PAIR* thisPair;
  855. {
  856.   int offset = getVARoffset(thisPair);
  857.   
  858.     return((OBJECT**)((int**)ctxtObject->mfa + offset));
  859. }
  860.  
  861.  
  862. /* countAllPairs(): count all the pairs in the given context */
  863.  
  864. int countAllPairs(context)
  865. CONTEXT* context;
  866. {
  867.   PAIR* thisPair = context->firstPair;
  868.   int    count = 0;
  869.   
  870.     while (thisPair) {
  871.           count++;
  872.         thisPair = thisPair->sfa;
  873.     }
  874.     
  875.     return(count);
  876. }
  877.  
  878.  
  879. /* countDataPairs(): count the data pairs in the given context */
  880. /* (REF, VAR, SHAREDVAR, CONST) */
  881.  
  882. int countDataPairs(context)
  883. CONTEXT* context;
  884. {
  885.   PAIR* thisPair = context->firstPair;
  886.   int count = 0;
  887.   
  888.      while (thisPair) {
  889.         if (thisPair->ofa) switch(recognizeObject(thisPair->ofa)) {
  890.             case REF:
  891.             case VAR:
  892.             case CONST:
  893.                 count++;
  894.                 break;
  895.         }
  896.          thisPair = thisPair->sfa;
  897.      }
  898.       return(count);
  899. }
  900.  
  901.  
  902. /* countOperPairs(): count the method pairs in the given context */
  903.  
  904. int countOperPairs(context)
  905. CONTEXT* context;
  906. {
  907.   PAIR* thisPair = context->firstPair;
  908.   int count = 0;
  909.   
  910.      while (thisPair) {
  911.         if (thisPair->ofa) switch(recognizeObject(thisPair->ofa)) {
  912.             case PRIMITIVE:
  913.             case METHOD:
  914.                 count++;
  915.                 break;
  916.         }
  917.          thisPair = thisPair->sfa;
  918.      }
  919.     return(count);
  920. }
  921.  
  922.  
  923. /* findAllAsIndexed(): find the n'th pair in the given context */
  924.  
  925. PAIR* findAllAsIndexed(context, index)
  926. CONTEXT* context;
  927. int      index;
  928. {
  929.     PAIR* tempPair = context->firstPair;
  930.  
  931.     while (--index && tempPair) tempPair = tempPair->sfa;
  932.     
  933.     return(tempPair);
  934. }
  935.  
  936.  
  937. /* findDataAsIndexed(): find the n'th data pair in the given context */
  938.  
  939. PAIR* findDataAsIndexed(context, index)
  940. CONTEXT* context;
  941. int         index;
  942. {
  943.     PAIR* tempPair = context->firstPair;
  944.  
  945.     while (tempPair) {
  946.         if (tempPair->ofa) switch(recognizeObject(tempPair->ofa)) {
  947.             case REF:
  948.             case VAR:
  949.             case CONST:
  950.                 if (--index == 0) return(tempPair);
  951.                 break;
  952.         }
  953.         tempPair = tempPair->sfa;
  954.     }
  955.     return(NIL);
  956. }
  957.  
  958.  
  959. /* findOperAsIndexed(): find the n'th method pair in the given context */
  960.  
  961. PAIR* findOperAsIndexed(context, index)
  962. CONTEXT* context;
  963. int         index;
  964. {
  965.     PAIR* tempPair = context->firstPair;
  966.  
  967.     while (tempPair) {
  968.         if (tempPair->ofa) switch(recognizeObject(tempPair->ofa)) {
  969.             case PRIMITIVE:
  970.             case METHOD:
  971.                 if (--index == 0) return(tempPair);
  972.                 break;
  973.         }
  974.         tempPair = tempPair->sfa;
  975.     }
  976.     return(NIL);
  977. }
  978.  
  979.  
  980. /* Check the integrity of the given context by performing several checks */
  981.  
  982. void checkIntegrity(context)
  983. CONTEXT* context;
  984. {
  985.   int fwdCount = countAllPairs(context);
  986.   int bwdCount = 0;
  987.   int thread;
  988.   int error = FALSE;
  989.  
  990.     for (thread = 0; thread < CONTEXTSIZE; thread++) {
  991.         PAIR* thisPair = context->lastPair[thread];
  992.         PAIR* tempPair;
  993.             
  994.         while (thisPair) {
  995.             bwdCount++;
  996.  
  997.             if (hash(thisPair->nfa) != thread) {
  998.                 fprintf(confile, "== Integrity error detected: name in wrong thread ==\n");
  999.                 error = TRUE;
  1000.             }
  1001.             
  1002.             if (thisPair->cfa != context) {
  1003.                 fprintf(confile, "== Integrity error detected: name in wrong context ==\n");
  1004.                 error = TRUE;
  1005.             }
  1006.             
  1007.             tempPair = context->firstPair;
  1008.             while (tempPair) {
  1009.                 if (tempPair == thisPair) goto forw1;
  1010.                 tempPair = tempPair->sfa;
  1011.             }
  1012.             fprintf(confile, "== Integrity error detected: name not found in successor link ==\n");
  1013.             error = TRUE;
  1014.  
  1015. forw1:
  1016.             thisPair = thisPair->lfa;
  1017.         }
  1018.     }
  1019.  
  1020.     if (fwdCount != bwdCount) {
  1021.         fprintf(confile, "== Integrity error detected: link counts do no match ==\n");
  1022.         error = TRUE;
  1023.     }
  1024.  
  1025.     if (fwdCount) {
  1026.         if (context->latestPair == NIL) {
  1027.             fprintf(confile, "== Integrity error detected: latest pair is NIL although context isn't empty ==\n");
  1028.             error = TRUE;
  1029.         }
  1030.     }    
  1031.  
  1032.     if (bwdCount) {
  1033.         if (context->firstPair == NIL) {
  1034.             fprintf(confile, "== Integrity error detected: first pair is NIL although context isn't empty == \n");
  1035.             error = TRUE;
  1036.         }
  1037.     }
  1038.  
  1039.     if (context->latestPair != NIL) {
  1040.         for (thread = 0; thread < CONTEXTSIZE; thread++) {
  1041.             if (context->lastPair[thread] == context->latestPair) goto forw2;
  1042.         }
  1043.         fprintf(confile, "== Integrity error detected: latest pair not found among last pairs ==\n");
  1044.         error = TRUE;
  1045.     }
  1046.  
  1047.     if (!checkFamilyIntegrity(context)) error = TRUE;
  1048.  
  1049. forw2:
  1050.     if (error) reportIntegrityError();
  1051. }
  1052.